home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / primops / locations.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  10.5 KB  |  229 lines
  1. (herald locations
  2.   (env (*value orbit-env 'base-early-binding-env) primops))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. (define-constant setter
  28.   (%operation '#f 'setter handle-operation))
  29.  
  30. (declare simplifier setter simplify-setter)
  31.  
  32. (define-constant make-location 
  33.   (primop make-location (name offset rep quasi-type nargs
  34.                          type contents-type set-type)
  35.  
  36.     (((primop.simplify self node)
  37.       (simplify-parameterized-primop self node)))
  38.  
  39.     ((primop.variant-id self) name)
  40.     ((primop.location? self) t)
  41.     ((primop.location-specs self) offset)
  42.     ((primop.rep-wants self) rep)
  43.     ((primop.make-closed self)
  44.      (case offset 
  45.        ((vector)                                 
  46.            `(*define-vector-accessor ',name ,quasi-type
  47.                  (lambda (x i) (,primop/contents-location ,self x i))
  48.                  (lambda (x i v) (,primop/set-location ,self v x i))))
  49.         ((1 -3)
  50.          `(object (lambda (x)          
  51.                     (let ((x (if (list? x) x (*enforce list? x))))
  52.                       (,primop/contents-location ,self x)))
  53.              ((setter self)
  54.               (lambda (x v)
  55.                 (let ((x (if (pair? x) x (*enforce pair? x))))
  56.                   (,primop/set-location ,self v x))))
  57.          ((identification self) ',name)))
  58.         (else
  59.          `(*define-accessor ',name ,quasi-type ,(fx/ (fx- offset 2) 4)))))
  60.     ((primop.simplify self node)
  61.      (simplify-location node))
  62.     ((primop.settable? self) t)
  63.     ((primop.simplify-setter self call)
  64.      (simplify-location-set self call nargs))
  65.     ((primop.type self node) type)
  66.     ((primop.contents-type self) contents-type)
  67.     ((primop.set-type self) set-type)))
  68.  
  69. (define-constant make-structure-accessor
  70.   (primop make-structure-accessor (offset)
  71.  
  72.     (((primop.simplify self node)
  73.       (simplify-parameterized-structure-accessor self node))
  74.      ((primop.make-closed self)
  75.       '(lambda (stype #f id) (stype-selector stype id))))
  76.  
  77.     ((primop.location? self) t)
  78.     ((primop.location-specs self) offset)
  79.     ((primop.rep-wants self) 'rep/pointer)
  80.      
  81.     ((primop.simplify self node)
  82.      (simplify-location node))
  83.     ((primop.settable? self) t)
  84.     ((primop.simplify-setter self call)
  85.      (simplify-location-set self call 1))
  86.     ((primop.type self node)
  87.      '#[type (object (proc #f (proc #f top) top)
  88.                      (setter #f (proc (#f (proc #f top top)))))])))
  89.  
  90. (define-local-syntax (define-accessor name offset arg-type qtype . contents)
  91.   (let* ((s-type (if (eq? arg-type 'list) 'pair arg-type))
  92.          (c-type (if (null? contents) 'top (car contents)))
  93.          (type (->type `(object (proc #f (proc #f ,c-type) ,arg-type)
  94.                           (setter #f (proc #f (proc #f ,s-type ,c-type))))))
  95.          (contents-type (->type `(proc #f (proc #f ,c-type) top ,arg-type)))
  96.          (set-type (->type `(proc #f (proc #f) top ,c-type ,s-type))))
  97.     `(define-constant ,name
  98.                       (make-location ',name
  99.                                      ,(if (eq? arg-type 'list)
  100.                                           (fx- (fx* offset 4) 3)
  101.                                           (fx+ (fx* offset 4) 2))
  102.                                      'rep/pointer
  103.                                      ',qtype
  104.                                      1
  105.                                      ',type
  106.                                      ',contents-type
  107.                                      ',set-type))))
  108.                                    
  109. (define-accessor cdr                    0 list    list?)
  110. (define-accessor car                    1 list    list?)
  111. (define-accessor string-text            0 string  string? text)
  112. (define-accessor cell-value             0 cell    true?)
  113. (define-accessor foreign-name           0 foreign foreign?)
  114. (define-accessor symbol-hash            0 symbol  symbol?)
  115. (define-accessor vcell-contents         0 vcell   vcell?)
  116. (define-accessor vcell-locations        1 vcell   vcell?)
  117. (define-accessor vcell-id               2 vcell   vcell?)
  118. (define-accessor vcell-vcell-locations  3 vcell   vcell?)
  119. (define-accessor state-unwinder         0 top     true?)
  120. (define-accessor state-previous         1 top     true?)
  121. (define-accessor state-winder           2 top     true?)
  122. (define-accessor state-next             3 top     true?)
  123. (define-accessor extend-header         -1 top     extend?)
  124. (define-accessor %operation-default     0 top     true?)
  125. (define-accessor %operation-id          1 top     true?)
  126. (define-accessor %operation-handler     2 top     true?)
  127. (define-accessor stype-handler          0 top     stype?)
  128. (define-accessor stype-predicator       1 top     stype?)
  129. (define-accessor stype-constructor      2 top     stype?)
  130. (define-accessor stype-selectors        3 top     stype?)
  131. (define-accessor stype-master           4 top     stype?)
  132. (define-accessor stype-id               5 top     stype?)
  133. (define-accessor unit-source-filename   0 unit    unit?)
  134. (define-accessor unit-herald            1 unit    unit?)
  135. (define-accessor unit-env               2 unit    unit?)
  136. (define-accessor joined-lhs             0 top     joined?)
  137. (define-accessor joined-rhs             1 top     joined?)
  138. (define-accessor bogus-entity-procedure 0 top     bogus-entity?)
  139. (define-accessor bogus-entity-handler   1 top     bogus-entity?)
  140. (define-accessor weak-set-elements   0 top weak-set?)
  141. (define-accessor weak-alist-elements 0 top weak-alist?)
  142. (define-accessor weak-table-table    0 top weak-table?)
  143. (define-accessor weak-table-vector   1 top weak-table?)
  144. (define-accessor weak-cell-contents  0 top weak-cell?)
  145.  
  146. (define-constant vector-type-length
  147.   (primop vector-type-length (name type)
  148.  
  149.     (((primop.simplify self node)
  150.       (simplify-parameterized-primop self node)))
  151.                                    
  152.     ((primop.variant-id self) name)
  153.     ((primop.type self node) type)
  154.     ((primop.generate self node)
  155.      (generate-vector-type-length node))))
  156.  
  157. (define-local-syntax (define-vector-type-length name)
  158.   (let ((full-name (concatenate-symbol name '-length))
  159.         (type (->type `(proc #f (proc #f fixnum) ,name))))
  160.     `(define-constant ,full-name
  161.                       (vector-type-length ',full-name ',type))))
  162.                                    
  163.  
  164. (define-vector-type-length vector )
  165. (define-vector-type-length bytev )
  166. (define-vector-type-length text )
  167. (define-vector-type-length unit )
  168. (define-vector-type-length symbol )
  169. (define-vector-type-length bignum )
  170. (define-vector-type-length stack )
  171.  
  172. ;;; This must come before STRING-LENGTH
  173. (define-constant set-string-length
  174.   (primop set-string-length () 
  175.     ((primop.side-effects? self) t)
  176.     ((primop.generate self node)
  177.      (generate-set-vector-type-length node))
  178.     ((primop.type self node) '#[type (proc #f (proc #f) string fixnum)])))
  179.  
  180. (define-constant string-length
  181.   (primop string-length ()
  182.     ((primop.generate self node)
  183.      (generate-vector-type-length node))
  184.     ((primop.settable? self) t)
  185.     ((primop.simplify-setter self call)
  186.      (replace (call-proc call) 
  187.               (create-primop-node (table-entry primop-table
  188.                                                'set-string-length))))
  189.     ((primop.type self node)
  190.      '#[type (object (proc #f (proc #f fixnum) string)
  191.                      (setter #f (proc #f (proc #f string fixnum))))])
  192.     ((primop.make-closed self)
  193.      '(object (lambda (s)
  194.                 (string-length (enforce string? s)))
  195.         ((setter self)
  196.          (lambda (s i)
  197.            (if (and (string? s)
  198.                     (fx<= i (text-length (string-text s))))
  199.                (set-string-length s i)
  200.                (error "error in string-length ~s" 
  201.                       (list 'set (list 'string-length s) i)))))))))
  202.                 
  203. ;;; vector accessors take two specifiers 
  204. ;;; type of object
  205. ;;; representation it yields by default and expects
  206.  
  207. (define-local-syntax (define-vector-accessor name quasi-type type rep . c-type)
  208.   (let* ((c-type (if (null? c-type) 'fixnum (car c-type)))
  209.          (r-type (->type
  210.                   `(object (proc #f (proc #f ,c-type) ,type fixnum)
  211.                            (setter #f (proc #f (proc #f ,type fixnum ,c-type))))))
  212.          (contents-type (->type `(proc #f (proc #f ,c-type) top ,type fixnum)))
  213.          (set-type (->type `(proc #f (proc #f) top ,c-type ,type fixnum))))
  214.     `(define-constant ,name
  215.        (make-location ',name 'vector ',rep ',quasi-type 2
  216.                       ',r-type ',contents-type ',set-type))))
  217.  
  218. (define-vector-accessor vector-elt         vector? vector rep/pointer top)
  219. (define-vector-accessor bignum-digit       bignum? bignum rep/pointer)
  220. (define-vector-accessor extend-pointer-elt extend? top    rep/pointer top)
  221. (define-vector-accessor text-elt           text?   text   rep/char    char)
  222. (define-vector-accessor symbol-elt         symbol? symbol rep/char    char)
  223. (define-vector-accessor mref-8-u           extend? top    rep/integer-8-u)
  224. (define-vector-accessor mref-8-s           extend? top    rep/integer-8-s)
  225. (define-vector-accessor mref-16-u          extend? top    rep/integer-16-u)
  226. (define-vector-accessor mref-16-s          extend? top    rep/integer-16-s)
  227. (define-vector-accessor mref-integer       extend? top    rep/integer)
  228. ;(define-vector-accessor mref-32            bytev?  bytev  rep/integer-32)
  229. (define-vector-accessor string-elt         string? string rep/string char)